home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 003 / db_dbug2.arc / DB_STRCT.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1987-03-10  |  12.3 KB  |  339 lines
  1. {program DB_STRCT
  2.  This is one of a series of utilities intended for analyzing dBASE III .PRG
  3.  files.  This program examines the program flow of all available .PRG files in
  4.  a tree structure, and then prints out that tree structure, followed by a
  5.  listing of the variables encountered in each .PRG file.  At the same time, it
  6.  also checks for IF-, DO WHILE-, and DO CASE- loop mismatches.
  7.  
  8.                                          Written by Curtis H. Hoffmann
  9.  
  10. version A2 03/10/87
  11.  
  12.    A1 10/20/86   Initial Release
  13.    A2 03/10/87   Check for nonexistant .PRG in DO filename statement
  14. }
  15.  
  16.  
  17. const
  18.    dash1 = '------------------------------------';
  19.    blanks= '                                    ';
  20.  
  21. type
  22.    name = string[12];
  23.    stt  = string[255];
  24.    datetype = string[8];
  25.     regtype =record
  26.              ax,bx,cx,dx,bp,si,di,ds,es,flags: integer
  27.              end;
  28.  
  29. var
  30.    file_in, file_out           : text;
  31.    all_files, abo              : char;
  32.    in_file, ofl                : string[8];
  33.    out_file                    : string[12];
  34.    progs                       : array[1..100] of string[8];
  35.    doloop                      : array[1..100] of string[1];
  36.    varibs                      : array[1..255] of string[10];
  37.    prog_stack, line_stack      : array[1..20]  of integer;
  38.    ps, sp, ln_cnt, vp, lp, dp  : integer;
  39.    st, outstring, path         : string[255];
  40.    next_word, this_word        : string[10];
  41.    more_words, pass_one, skip_line   : boolean;
  42.  
  43. {doloop can be C, D, or I for Do Case, Do While, or If Then}
  44.  
  45.  
  46. function time: datetype;
  47. var reg:     regtype;
  48.     h,m,s,w: datetype;
  49.     i:       integer;
  50.  
  51. begin
  52.    reg.ax:=$2c00;
  53.    intr($21,reg);
  54.    str(hi(reg.cx):2,h);
  55.    str(lo(reg.cx):2,m);
  56.    str(hi(reg.dx):2,s);
  57.    w:=h+':'+m+':'+s;
  58.    for i:=1 to length(w) do if w[i]=' ' then w[i]:='0';
  59.    time:=w;
  60. end;
  61.  
  62. function date: datetype;
  63. var reg:     regtype;
  64.     y,m,d,w: datetype;
  65.     i:       integer;
  66.  
  67. begin
  68.    reg.ax:=$2a00;
  69.    intr($21,reg);
  70.    str(reg.cx:4,y);
  71.    delete(y,1,2);
  72.    str(hi(reg.dx):2,m);
  73.    str(lo(reg.dx):2,d);
  74.    w:=m+'/'+d+'/'+y;
  75.    for i:=1 to length(w) do if w[i]=' ' then w[i]:='0';
  76.    date:=w;
  77. end;
  78.  
  79. function exist(filename: name): boolean;     {Check to see if I/O files exist}
  80. var fil: file;
  81. begin
  82.    assign(fil, filename);
  83.    {$I-}
  84.    reset(fil);
  85.    {$I+}
  86.    exist:=(IOresult=0);
  87.    close(fil);
  88. end;
  89.  
  90. function standard_io(h :name): boolean;     {If output is to screen or printer}
  91. begin                                       {then don't check for existance}
  92.    if ((h='prn') or (h='PRN')) or ((h='con') or (h='CON')) then
  93.       standard_io:=true
  94.    else standard_io:=false;
  95. end;
  96.  
  97. procedure get_started;                      {Opening screen, get filenames}
  98. var j: integer;
  99.     ow: char;
  100. begin
  101.    abo:='N'; clrscr; gotoxy(10,10);
  102.    write('Input .PRG file to check first          : '); read(in_file); gotoxy(10,12);
  103.    write('File to dump output to (prn for printer): '); read(out_file); gotoxy(10,14);
  104.    write('Check all files, or just this one (A/O) : '); readln(all_files);
  105.    all_files:=upcase(all_files);
  106.    if not exist(in_file+'.prg') then begin
  107.       writeln(in_file+'.PRG does not exist, program aborted'); abo:='Y'; end
  108.    else begin
  109.       for j:=1 to length(in_file) do if (in_file[j]>='a') and (in_file[j]<='z') then in_file[j]:=upcase(in_file[j]);
  110.       assign(file_in, in_file+'.prg'); reset(file_in);
  111.    end;
  112.    textcolor(12);
  113.    if not standard_io(out_file) then if exist(out_file) then begin
  114.       write(out_file+' exists, overwrite it (Y/N)?: '); readln(ow);
  115.       if upcase(ow)<>'Y' then begin write('Program aborted'); abo:='Y'; end;
  116.    end;
  117.    textcolor(14);
  118.    progs[1]:=in_file;
  119.    if abo<>'Y' then begin assign(file_out, out_file); rewrite(file_out); end;
  120. end;
  121.  
  122. procedure init;                              {Initialize stacks and pointers}
  123. var i: integer;
  124. begin
  125.    getdir(0,path);
  126.    outstring:='';    pass_one:=true;   ln_cnt:=0;
  127.    sp:=1;            ps:=1;            prog_stack[sp]:=1;
  128.    for i:=1 to 20 do line_stack[i]:=0;
  129. end;
  130.  
  131.  
  132. procedure push_stack;                {Put current file in top of stack prior}
  133. var y: integer;                      {to jumping to next called file.  Write}
  134. begin                                {name of file as part of tree structure.}
  135.    line_stack[ps]:=ln_cnt; ps:=ps+1; y:=1;
  136.    while (y<=sp) and (next_word<>progs[y]) do y:=y+1;
  137.    if y>sp then begin sp:=sp+1; progs[sp]:=next_word; end;
  138.    prog_stack[ps]:=y; close(file_in);
  139.    assign(file_in, progs[prog_stack[ps]]+'.prg'); reset(file_in);
  140.    ln_cnt:=0;
  141.    writeln(file_out,outstring+'----'+progs[prog_stack[ps]]+copy(dash1,1,8-length(progs[prog_stack[ps]])));
  142.    outstring:=outstring+'            ';
  143. end;
  144.  
  145. procedure pop_stack;              {Done with current file, so pop last}
  146. var i: integer;                   {pushed file from stack, make it current}
  147. begin                             {and write out its name in the tree format}
  148.    if ps>1 then begin
  149.       ps:=ps-1; ln_cnt:=line_stack[ps]; close(file_in);
  150.       assign(file_in, progs[prog_stack[ps]]+'.prg'); reset(file_in);
  151.       for i:=1 to ln_cnt do readln(file_in, st);
  152.       outstring:=copy(outstring,1,length(outstring)-12); end
  153.    else ps:=0;
  154. end;
  155.  
  156. function ltrim(var stg: stt): stt;           {Remove leading blanks}
  157. begin
  158.    while (stg[1]=' ') and (length(stg)>0) do stg:=copy(stg,2,length(stg));
  159.    ltrim:=stg;
  160. end;
  161.  
  162. procedure prep_line;               {Add spaces to seperate certain}
  163. var bb: integer;                   {words, eliminate unprintable characters}
  164.     cc: string[3];
  165.     nn: string[255];
  166.     nb_quote: boolean;
  167. begin
  168.    nn:=''; cc:=''; nb_quote:=false;
  169.    for bb:=1 to length(st) do begin
  170.       cc:=st[bb];
  171.       if (cc='"') or (ord(cc)=39) then nb_quote:=true;
  172.       if (cc=',') or ((ord(cc)<31) or (ord(cc)>127)) then cc:=' ';
  173.       if (cc='=') and (not nb_quote) then cc:=' '+cc+' ';
  174.       nn:=nn+cc;
  175.    end;
  176.    st:=nn;
  177. end;
  178.  
  179. function get_word(var line: stt): stt;       {Find next word in sentence}
  180. var word: string[20];
  181. begin
  182.    st:=ltrim(st); word:='';
  183.    while (length(st)>0) and (st[1]<>' ') do begin
  184.       word:=word+upcase(st[1]);
  185.       st:=copy(st,2,length(st));
  186.    end;
  187.    get_word:=word;
  188. end;
  189.  
  190. procedure parse;                             {Get words from sentence}
  191. begin
  192.    st:=ltrim(st);
  193.    if length(this_word)>0 then begin
  194.       this_word:=next_word; next_word:=get_word(st); end
  195.    else begin
  196.       this_word:=get_word(st); next_word:=get_word(st);
  197.    end;
  198.    more_words:=false;
  199.    if (length(st)>0) or (length(this_word)>0) then more_words:=true;
  200. end;
  201.  
  202. procedure first_char;                       {Flag any comments or empty lines}
  203. begin                                       {so they can be skipped}
  204.    skip_line:=false; st:=ltrim(st);
  205.    if (length(st)=0) or (st[1]='*') then skip_line:=true;
  206. end;
  207.  
  208. procedure add_f;                            {Add new variables to the list}
  209. var y, t: integer;                          {and sort in alphabetical order}
  210. begin
  211.    if vp=0 then begin varibs[1]:=this_word; vp:=1; end
  212.    else begin
  213.       for y:=1 to vp do if this_word=varibs[y] then y:=vp+5
  214.       else if this_word<varibs[y] then begin
  215.          vp:=vp+1; t:=vp;
  216.          while t>y do begin
  217.             varibs[t]:=varibs[t-1]; t:=t-1;
  218.          end;
  219.          varibs[y]:=this_word; y:=vp+5;
  220.       end;
  221.       if (this_word>varibs[vp]) and (y<vp+2) then begin
  222.          vp:=vp+1; varibs[vp]:=this_word;
  223.       end;
  224.    end;
  225. end;
  226.  
  227. procedure pop_loop;            {This uses the stack containing the currently}
  228. var yw: string[10];            {in-force loop statement: DO, IF, CASE.  Pop}
  229. begin                          {it when the matching END statement is found.}
  230.    if dp<1 then writeln(file_out,'Caution!  ',progs[ps],' has an excess of ',this_word,' statements!')
  231.    else if this_word[4]=doloop[dp] then begin
  232.       doloop[dp]:=''; dp:=dp-1;
  233.    end
  234.    else begin
  235.       writeln(file_out);
  236.       writeln(file_out,'Caution!  ',progs[ps],' has mismatched loop statements.');
  237.       if doloop[dp]='I' then yw:='ENDIF' else if doloop[dp]='D' then yw:='ENDDO' else yw:='ENDCASE';
  238.       writeln(file_out,'Expecting ',yw,', found ',this_word,'.');
  239.       writeln(file_out); write(file_out,'     ');
  240.    end;
  241. end;
  242.  
  243. procedure what_cmd;            {Find the matching shortened form of a command}
  244. var tw, nw: string[4];         {and perform the appropriate operations}
  245. begin
  246.    tw:=this_word; nw:=next_word;
  247.    if all_files='A' then begin
  248.       if (pass_one and (tw='DO')) and ((nw<>'CASE') and (nw<>'WHIL')) then if exist(next_word+'.prg') then push_stack
  249.          else begin
  250.             write(file_out,'Alert: DO ',next_word,' encountered in ',progs[prog_stack[ps]],'.PRG');
  251.             writeln(file_out,'  ',next_word,'.PRG not found.');
  252.          end;
  253.    end;
  254.    if (not pass_one) then begin
  255.       if (tw='DO') and ((nw='CASE') or (nw='WHIL')) then begin
  256.          dp:=dp+1;
  257.          if nw='CASE' then doloop[dp]:='C' else doloop[dp]:='D';
  258.       end;
  259.       if tw='IF' then begin dp:=dp+1; doloop[dp]:='I'; end;
  260.       if (tw='ENDC') or ((tw='ENDI') or (tw='ENDD')) then pop_loop;
  261.       if tw='PUBL' then while more_words do begin
  262.          parse; if length(this_word)>0 then add_f;
  263.       end;
  264.       if ((tw='ACCE') or (tw='COUN')) or ((tw='INPU') or (tw='WAIT')) then while more_words do begin
  265.          parse;
  266.          if this_word='TO' then begin
  267.             this_word:=next_word; add_f; more_words:=false;
  268.          end;
  269.       end
  270.       else if ((tw='STOR') or (tw='AVER')) then while more_words do begin
  271.          parse;
  272.          if this_word='TO' then while more_words do begin
  273.             parse; if length(this_word)>0 then add_f;
  274.          end
  275.          else if (tw='SUM') then while more_words do begin
  276.             parse;
  277.             if this_word='TO' then while more_words and ((this_word<>'FOR') and (this_word<>'WHILE')) do begin
  278.                parse; if length(this_word)>0 then add_f;
  279.             end;
  280.          end;
  281.       end;
  282.       if nw='=' then add_f;
  283.    end;
  284.    more_words:=false;
  285. end;
  286.  
  287. procedure get_line;              {Get the next sentence from the file}
  288. begin                            {and operate on it}
  289.    readln(file_in,st); prep_line;
  290.    this_word:=''; next_word:=''; more_words:=true;
  291.    if pass_one then ln_cnt:=ln_cnt+1;
  292.    first_char;
  293.    if not skip_line then while more_words begin
  294.       parse; what_cmd;
  295.    end;
  296. end;
  297.  
  298. begin                            {Main body of the program}
  299.    get_started; init;            {Print the tree structure}
  300.    if abo<>'Y' then begin
  301.       writeln(file_out,'         dBASE III Program Structure Report     for directory '+path);
  302.       write(file_out,'Starting with: '+in_file+'.PRG'+copy(blanks,1,8-length(in_file)));
  303.       writeln(file_out,'                     run at ',time,' on ',date);
  304.       writeln(file_out);
  305.       writeln(file_out,in_file+copy(dash1,1,12-length(in_file)));
  306.       outstring:='            ';
  307.       while ps>0 do begin
  308.          while not eof(file_in) do get_line;
  309.          pop_stack;
  310.       end;
  311.                                  {Print the variables used list and check}
  312.       writeln(file_out);         {for mismatched loop statements}
  313.       writeln(file_out,'=======================================================================================');
  314.       for ps:=1 to 4 do writeln(file_out);
  315.       writeln(file_out,'         Variables used in the above files');
  316.       pass_one:=false; vp:=0;
  317.       for ps:=1 to sp do begin
  318.          writeln(file_out); lp:=1; vp:=0; dp:=0;
  319.          for ln_cnt:=1 to 255 do varibs[ln_cnt]:='';
  320.          writeln(file_out,progs[ps]); write(file_out,'     ');
  321.          close(file_in); assign(file_in,progs[ps]+'.prg'); reset(file_in);
  322.          while not eof(file_in) do get_line;
  323.          for ln_cnt:=1 to vp do begin
  324.             if lp<9 then lp:=lp+1 else begin
  325.                lp:=2; writeln(file_out); write(file_out,'     ');
  326.             end;
  327.             write(file_out,varibs[ln_cnt],copy(blanks,1,12-length(varibs[ln_cnt])));
  328.          end;
  329.          writeln(file_out);
  330.          for ln_cnt:=1 to dp do begin
  331.             if doloop[ln_cnt]='I' then st:='ENDIF' else if doloop[ln_cnt]='C' then st:='ENDCASE' else st:='ENDDO';
  332.             writeln(file_out,'Caution!  Missing '+st+' at end of '+progs[ps]+'.');
  333.          end;
  334.          writeln(file_out);
  335.       end;
  336.    end;
  337. close(file_in); close(file_out);
  338. end.
  339.